perm filename F8C.F4[F8,ALS]1 blob
sn#297063 filedate 1977-07-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00010 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 $CONTROL USLINIT
C00020 00003 C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C00036 00004 INTEGER FUNCTION IASCI(K)
C00042 00005 SUBROUTINE LIST (IBCT,I1,I2,I3,IMAGE)
C00047 00006 KFG=.TRUE.
C00053 00007 SUBROUTINE LR(IN,I,IV)
C00061 00008 SUBROUTINE OPSRC(S,I)
C00069 00009 SUBROUTINE HXOUT (I,I1,I2,ICK)
C00078 00010 SUBROUTINE SCERR(J)
C00084 ENDMK
C⊗;
$CONTROL USLINIT
$CONTROL FILE=15,FILE=16,FILE=19
C PROGRAM F8CAM
C FAIRCHILD MICROSYSTEMS MINICOMPUTER CROSS ASSEMBLER
C
C THIS PROGRAM IS DESIGNED TO EXECUTE ON ANY 16 BIT COMPUTER
C SUPPORTING FORTRAN 4. MINOR MODIFICATIONS WILL BE NEEDED
C TO SATISFY ANY PARTICULAR OPERATING SYSTEM AND COMPUTER.
C A SPECIAL COMMENT SECTION HAS BEEN INCLUDED IN THIS PROGRAM
C NEAR SECTIONS LIKELY TO REQUIRE MODIFICATION. THE SECTIONS
C ARE BOUNDED WITH THE FOLLOWING COMMENT:
C
C SYSTEM DEPENDENT **************************** SYSTEM DEPENDENT
C
C
C AS DELIVERED, THE PROGRAM WILL ASSEMBLE 100 SYMBOLS. THOSE
C STATEMENTS WHICH MUST BE CHANGED TO INCREASE THIS NUMBER ARE
C PRECEDED BY THE FOLLOWING COMMENT:
C
C SYMBOL TABLE SIZE ************************ SYMBOL TABLE SIZE
C
C CHANGE THE NUMBER 100 TO THE DESIRED NUMBER OF SYMBOLS. IT
C MAY BE EXPEDIENT TO COMPILE AND LOAD THE PROGRAM AS IS TO
C DETERMINE THE AMOUNT OF MEMORY LEFT OVER FOR MORE SYMBOLS.
C
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12,OP34, OP56,OVAL,OTYP, CH12,CH34,CH56,SVALL,SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
LOGICAL LAB,PRNTF,PNCHF,ER,OF,PASS2,FLAG
EQUIVALENCE (LBK,LETAB(1)),(LAP,LETAB(47))
DIMENSION IMAGE(80) ,ITEST(6)
INTEGER FIELD(6),EXPR(32),FLG
DATA KS/20/,KI/10/,KD/5/
DATA KF/7/,KO/16/
C
C INITIALIZE COMMON CONSTANTS
C
CALL BLOCK
C
IERC = 0
C
C
C SYMBOL TABLE SIZE *************************** SYMBOL TABLE SIZE
C
DO 100 I=1,800
CH12(I)=0
CH34(I)=0
CH56(I)=0
SVALL(I)=0
SVALH(I)=0
SFLG(I)=0
100 CONTINUE
C
C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C
C THE FOLLOWING FOUR STATEMENTS DEFINE THE LOGICAL UNITS USED
C BY THE PROGRAM. THEY SHOULD BE SET APPROPRIATELY FOR THE
C SYSTEM TO BE USED. IF THE OPERATING SYSTEM SUPPORTS A WAY
C OF READING PARAMETERS AT EXECUTION START-UP, APPROPRIATE CODE
C MAY BE SUBSTITUTED HERE.
C IC = SOURCE INPUT
C OC = SOURCE OUTPUT (WILL BE INPUT FOR SECOND PASS)
C PR = LISTING DEVICE
C PU = PUNCH OUTPUT
C
C IN ADDITION THE VARIABLE 'OF' SPECIFIES WHETHER A SOURCE OUTPUT
C DEVICE IS AVAILABLE (MUST BE REWINDABLE). SET TO .TRUE. IF AVAIL
C IF DEVICE IS A DISK, A 'OPEN FILE' SUBROUTINE CALL MAY BE
C NECESSARY.
C
IC = 20
OC = 21
PR = 22
PU = 23
OF=.TRUE.
LINECOUNT = 0
C
PRNTF=.TRUE.
PNCHF=.TRUE.
PASS2=.FALSE.
1000 LOCH=0
LOCL=0
IF (PASS2.AND.PNCHF) CALL PHDR
IF (PASS2.AND.PRNTF) CALL TOFM
C CLEAR LABEL FLAG
1010 LAB=.FALSE.
C
C READ A RECORD OF SOURCE
C
C
C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C
C IF THE TARGET COMPILER SUPPORTS:
C READ (IC,1,END=1470 ) IMAGE
C IT SHOULD BE USED INSTEAD OF THE FOLLOWING LINE
C
READ (IC,1,END=1470 ) IMAGE
1 FORMAT (80A1)
C
LINECOUNT = LINECOUNT + 1
C
C WRITE TO SECONDARY STORAGE IF NOT PASS2 AND DISK AVAILABLE
C
C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C
C IF DISK IS USED, A SUBROUTINE CALL MAY HAVE TO BE SUBSTITUTED
C
C IF(.NOT.PASS2.AND.OF) WRITE(OC,1) IMAGE
C IGNORE COMMENT CARDS
IBCT=0
IF (IMAGE(1).EQ.LAP) GO TO 1510
I=1
C CHECK FOR PRESENCE OF LABEL
IF (IMAGE(1).EQ.LBK) GO TO 1050
CALL GETFL(IMAGE,I,FIELD,6,ER)
C
IF (FIELD(1).GT.27) GO TO 1015
IF (.NOT.ER) GO TO 1020
1015 IF (PASS2) CALL SCERR(1)
GO TO 1050
1020 CALL HASH (FIELD,INS)
IF (INS.GT.0) GO TO 1030
IF (PASS2) CALL LABER
1030 IF (SFLG(INS).NE.4) GO TO 1040
IF (PASS2) CALL PHERR
C
GO TO 1050
1040 LAB=.TRUE.
LABL=LOCL
LABH=LOCH
C SCAN FOR OPERATOR
1050 CALL GETFL (IMAGE,I,FIELD,6,ER)
IF (.NOT.ER) GO TO 1060
IF (PASS2) CALL SCERR(2)
GO TO 1510
1060 CALL OPSRC (FIELD,INO)
C
IF (INO.GT.0) GO TO 1070
IF (PASS2) CALL OPERR
IBCT=1
I1=43
GO TO 1510
C BRANCH ON OP CODE TYPE
1070 ITYP=OTYP(INO)
GO TO(1080,1080,1080,1080,1160,1200,1200,1200,1200,1320,1340,1360
X,1380,1470,1080,1080),ITYP
C TYPES 1,2,3,4,15,16 - ONE BYTE
1080 IBCT=1
IF (.NOT.PASS2) GO TO 1490
IF (ITYP.NE.2) GO TO 1090
I1=OVAL(INO)
GO TO 1490
1090 IF (ITYP.NE.1) GO TO 1100
CALL LR (IMAGE,I,I1)
GO TO 1490
1100 CALL GETFL (IMAGE,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 1105
IF (.NOT.PASS2) GO TO 1490
CALL SCERR(3)
IVL=0
IVH=0
GO TO 1120
1105 IF (ITYP.NE.3.OR.EXPR(2).NE.KBK) GO TO 1110
IVH=0
IVL=0
IF (EXPR(1).EQ.KS) IVL=12
IF (EXPR(1).EQ.KI) IVL=13
IF (EXPR(1).EQ.KD) IVL=14
IF (IVL.NE.0) GO TO 1120
1110 CALL EXPRE (EXPR,IVL,IVH,ER,FLG)
CALL FLGCK (ER,FLG)
1120 IF (IVH.EQ.0) GO TO 1130
IVH=0
CALL OVFER
1130 IF (ITYP.EQ.3) IMAX=14
IF (ITYP.EQ.4) IMAX=15
IF (ITYP.EQ.15) IMAX=7
IF (ITYP.EQ.16) GO TO 1150
IF(IVL.LE.IMAX) GO TO 1140
1135 IVL=0
CALL OVFER
1140 I1=OVAL(INO)+IVL
GO TO 1490
1150 IF ((IVL.NE.1).AND.(IVL.NE.4)) GO TO 1135
IF (IVL.EQ.1) IVL=2
GO TO 1140
C TYPE 5 -DC
1160 CALL GETFL (IMAGE,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 1180
IF (PASS2) CALL SCERR(3)
I1=0
I2=0
1170 IBCT=2
GO TO 1490
1180 DO 2000 J=2,31
IF (EXPR(J).EQ.KKO) GO TO 2010
2000 CONTINUE
J=1
ICNT=1
GO TO 1185
2010 EXPR(J)=KBK
J=J+1
CALL EXPRE (EXPR,IVL,IVH,ER,FLG)
IF (PASS2) GO TO 2020
IBCT=IVL
GO TO 1490
2020 CALL FLGCK (ER,FLG)
ICNT=IVL
IF (IVH.NE.0) CALL OVFER
IF (ICNT.EQ.2) GO TO 1185
IF (ICNT.EQ.1) GO TO 1195
IF (EXPR(J).EQ.4.AND.EXPR(J+1).EQ.KAP) GO TO 2050
CALL EXPRE(EXPR(J),IVL,IVH,ER,FLG)
CALL FLGCK (ER,FLG)
IF (IVH.NE.0.AND.IVH.NE.255) CALL OVFER
IBCT=3
I1=IVL
I2=I1
I3=I1
IFN=80
2030 IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3)
IF (PRNTF.OR.ERF) CALL LIST (IBCT,I1,I2,I3,IMAGE)
DO 2040 I=1,IFN
2040 IMAGE (I)=LBK
IFN=1
LOCL=LOCL+IBCT
CALL M256(LOCL,LOCH)
ICNT=ICNT-IBCT
I2=I3
I1=I3
IF (ICNT.GT.3) GO TO 2030
2045 IBCT=ICNT
GO TO 1490
2050 IFN=80
J=J+2
IBCT=3
2070 IF (ICNT.LT.3) IBCT=ICNT
I1=I3
I2=I3
IF (EXPR(J).EQ.KAP) GO TO 2030
I1 = IASCI(EXPR(J))
I2=I1
I3=I2
IF (EXPR(J+1).EQ.KAP) GO TO 2030
I2=IASCI (EXPR(J+1))
I3=I2
IF (EXPR(J+2).EQ.KAP) GO TO 2030
I3=IASCI(EXPR(J+2))
J=J+3
IF (ICNT.LE.3) GO TO 1490
IF (J.GT.30) GO TO 2030
ICNT=ICNT-IBCT
IF (PRNTF.OR.ERF) CALL LIST(IBCT,I1,I2,I3,IMAGE)
IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3)
DO 2060 I=1,IFN
2060 IMAGE(I)=LBK
IFN=1
LOCL=LOCL+IBCT
CALL M256(LOCL,LOCH)
GO TO 2070
1185 CALL EXPRE(EXPR(J),IVL,IVH,ER,FLG)
IF (PASS2) CALL FLGCK (ER,FLG)
IF (IVH.NE.0.AND.IVH.NE.255.OR.ICNT.EQ.2) GO TO 1190
1187 I1=IVL
IBCT=1
GO TO 1490
1190 I1=IVH
I2=IVL
GO TO 1170
1195 CALL EXPRE (EXPR(J),IVL,IVH,ER,FLG)
CALL FLGCK(ER,FLG)
IF (IVH.NE.0.AND.IVH.NE.255) CALL OVFER
GO TO 1187
C TYPE 6,7,8,9 TWO BYTE
1200 IBCT=2
IF (.NOT.PASS2) GO TO 1490
I1=OVAL(INO)
CALL GETFL (IMAGE,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 1220
CALL SCERR (3)
1210 I2=0
GO TO 1490
1220 IF ((ITYP.NE.6).AND.(ITYP.NE.7)) GO TO 1270
J=1
1230 CALL EXPRE (EXPR(J),IVL,IVH,ER,FLG)
CALL FLGCK (ER,FLG)
IF (ITYP.NE.6) GO TO 1260
1240 IF ((IVH.EQ.0).OR.(IVH.EQ.255)) GO TO 1250
CALL OVFER
IVH=0
1250 I2=IVL
GO TO 1490
1260 IVL=IVL-LOCL-1
IVH=IVH-LOCH
CALL M256(IVL,IVH)
IF (IVL.GT.127.AND.IVH.NE.255) CALL OVFER
IF (IVL.LT.128.AND.IVH.NE.0) CALL OVFER
GO TO 1250
C BF OR BT -FIND THE COMMA
1270 DO 1280 J=2,31
IF (EXPR(J).EQ.KKO) GO TO 1290
1280 CONTINUE
CALL SCERR(3)
GO TO 1210
1290 EXPR(J)=KBK
J=J+1
CALL EXPRE(EXPR,IVL,IVH,ER,FLG)
CALL FLGCK (ER,FLG)
IF ((IVH.EQ.0).OR.(IVH.EQ.255)) GO TO 1300
CALL OVFER
IVH=0
1300 IMAX=15
IF (ITYP.EQ.8) IMAX=7
IF (IVL.LE.IMAX) GO TO 1310
CALL OVFER
IVL=0
1310 I1=I1+IVL
GO TO 1230
C TYPE 10 -3BYTE
1320 IBCT=3
IF (.NOT.PASS2) GO TO 1490
I1=OVAL(INO)
CALL GETFL (IMAGE,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 1330
CALL SCERR(3)
I2=0
I3=0
GO TO 1490
1330 CALL EXPRE(EXPR,IVL,IVH,ER,FLG)
CALL FLGCK (ER,FLG)
I2=IVH
I3=IVL
GO TO 1490
C TYPE 11 -ORG
1340 IBCT=0
CALL GETFL (IMAGE,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 1350
CALL SCERR(3)
GO TO 1490
1350 CALL EXPRE (EXPR,IVL,IVH,ER,FLG)
IF (PASS2) CALL FLGCK(ER,FLG)
LOCH=IVH
LOCL=IVL
IF (PASS2.AND.PNCHF) CALL PHDR
GO TO 1490
C TYPE 12 -EQU
1360 IBCT=0
CALL GETFL(IMAGE,I,EXPR,32,ER)
C
IF (.NOT.ER.AND.LAB) GO TO 1370
CALL SCERR(3)
LAB=.FALSE.
GO TO 1510
1370 CALL EXPRE (EXPR,IVL,IVH,ER,FLG)
IF (PASS2) CALL FLGCK(ER,FLG)
IF (SFLG(INS).EQ.2) GO TO 1375
SVALL(INS)=IVL
SVALH(INS)=IVH
SFLG(INS)=1
GO TO 1510
1375 IF (PASS2) CALL PHERR
GO TO 1510
C TYPE 13 -MISC PSUEDO-OPS
1380 CONTINUE
C EJECT
IF (INO.NE.27) GO TO 1390
IF (.NOT.PASS2) GO TO 1010
IF (PRNTF) CALL TOFM
GO TO 1010
C TITLE
1390 IF (INO.NE.58) GO TO 1420
J=1
DO 1400 K=I,80
HDR(J)=IMAGE(K)
1400 J=J+1
DO 1410 K=J,80
1410 HDR(K)=LBK
GO TO 1510
C PRINT AND PUNCH
1420 CALL GETFL(IMAGE,I,FIELD,6,ER)
IF (.NOT.ER) GO TO 1430
1425 IF (PASS2) CALL SCERR(3)
GO TO 1510
1430 IF (FIELD(1).NE.KO) GO TO 1425
IF (FIELD(2).EQ.KF) GO TO 1440
FLAG=.TRUE.
GO TO 1450
1440 FLAG=.FALSE.
1450 IF (INO.NE.54) GO TO 1460
PNCHF=FLAG
GO TO 1510
1460 PRNTF=FLAG
GO TO 1510
C TYPE 14 -END
1470 CONTINUE
C
IF (PASS2) GO TO 1480
PASS2=.TRUE.
LINECOUNT = 0
IF (.NOT.OF) GO TO 1000
C
C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C
C DISK FILES MAY NOT RESPOND TO ENDFILE AND REWIND COMMANDS
C
C ENDFILE OC
C
C---------------
IC=OC
GO TO 1000
1480 IF (PRNTF) WRITE (PR,3)
3 FORMAT (14X,3HEND)
WRITE (PR,4) IERC
4 FORMAT (18H NUMBER OF ERRORS=,I3)
IF (PNCHF) CALL OFINI
IF (PRNTF) CALL SYMLS
C
C SYSTEM DEPENDENT ******************************* SYSTEM DEPENDENT
C
C SUBSTITUTE APPROPRIATE WAY TO RETURN TO OPERATING SYSTEM
C
STOP
C FIX LABEL VALUE IF NECESSARY
1490 IF (.NOT.LAB) GO TO 1510
IF (SFLG(INS).NE.0) GO TO 1500
SVALL(INS)=LABL
SVALH(INS)=LABH
SFLG(INS)=2
1500 IF (SVALL(INS).EQ.LABL.AND.SVALH(INS).EQ.LABH) GO TO 1510
SFLG(INS)=4
CALL PHERR
C LINE ASSEMBLED,DO LISTING AND OUTPUT AS NEEDED
1510 IF (.NOT.PASS2) GO TO 1520
IF (PRNTF.OR.ERF) CALL LIST(IBCT,I1,I2,I3,IMAGE)
IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3)
1520 LOCL=LOCL+IBCT
CALL M256 (LOCL,LOCH)
GO TO 1010
END
SUBROUTINE BLOCK
C
C THIS SUBROUTINE INITIALIZES ASSEMBLER COMMON CONSTANTS
C
C ASSEMBLER COMMON
COMMON IERC, ERF,
. IC, OC, PR, PU,
. ILETAB(64),
. IHDR(80), IPAGE, LINE,
. IOP12(63), IOP34(63), IOP56(63), IOVAL(63), IOTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
.IKBK,IKPL,IKMI,IKAP,IKKO,
. IOPB(16), KB, ICK
INTEGER IHDR, IPAGE,
. IOP12, IOP34, IOP56, IOVAL, IOTYP, CH12, CH34, CH56, SVALL,
. SVALH, SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
INTEGER HDR(80),PAGE,OP12(63),OP34(63),OP56(63),OVAL(63),OTYP(63)
INTEGER LETAB(64)
DATA HDR/80*1H /,PAGE/0/
DATA LETAB/2H ,2HA ,2HB ,2HC ,2HD ,2HE ,2HF ,2HG ,2HH ,2HI ,2HJ ,
X2HK ,2HL ,2HM ,2HN ,2HO ,2HP ,2HQ ,2HR ,2HS ,2HT ,2HU ,2HV ,2HW ,
X2HX ,2HY ,2HZ ,2H0 ,2H1 ,2H2 ,2H3 ,2H4 ,2H5 ,2H6 ,2H7 ,2H8 ,2H9 ,
X2H] ,2H" ,2H# ,2H$ ,2H% ,2H& ,2H' ,2H( ,2H) ,2H* ,2H+ ,2H, ,2H- ,
X2H. ,2H/ ,2H: ,2H; ,2H, ,2H= ,2H> ,2H? ,2H@ ,2H[ ,2He ,2H! ,2H← ,
X2He /
DATA KBK/1/,KAP/44/,KPL/48/,KMI/50/,KKO/49/
DATA OP12(63)/32767/
C ADC
DATA OP12( 1)/ 261/,OP34( 1)/ 513/,OP56( 1)/ 129/,
X OVAL( 1)/ 142/,OTYP( 1)/ 2/
C AI
DATA OP12( 2)/ 266/,OP34( 2)/ 129/,OP56( 2)/ 129/,
X OVAL( 2)/ 36/,OTYP( 2)/ 6/
C AM
DATA OP12( 3)/ 270/,OP34( 3)/ 129/,OP56( 3)/ 129/,
X OVAL( 3)/ 136/,OTYP( 3)/ 2/
C AMD
DATA OP12( 4)/ 270/,OP34( 4)/ 641/,OP56( 4)/ 129/,
X OVAL( 4)/ 137/,OTYP( 4)/ 2/
C AS
DATA OP12( 5)/ 276/,OP34( 5)/ 129/,OP56( 5)/ 129/,
X OVAL( 5)/ 192/,OTYP( 5)/ 3/
C ASD
DATA OP12( 6)/ 276/,OP34( 6)/ 641/,OP56( 6)/ 129/,
X OVAL( 6)/ 208/,OTYP( 6)/ 3/
C BC
DATA OP12( 7)/ 388/,OP34( 7)/ 129/,OP56( 7)/ 129/,
X OVAL( 7)/ 130/,OTYP( 7)/ 7/
C BF
DATA OP12( 8)/ 391/,OP34( 8)/ 129/,OP56( 8)/ 129/,
X OVAL( 8)/ 144/,OTYP( 8)/ 9/
C BM
DATA OP12( 9)/ 398/,OP34( 9)/ 129/,OP56( 9)/ 129/,
X OVAL( 9)/ 145/,OTYP( 9)/ 7/
C BNC
DATA OP12(10)/ 399/,OP34(10)/ 513/,OP56(10)/ 129/,
X OVAL(10)/ 146/,OTYP(10)/ 7/
C BNO
DATA OP12(11)/ 399/,OP34(11)/2049/,OP56(11)/ 129/,
X OVAL(11)/ 152/,OTYP(11)/ 7/
C BNZ
DATA OP12(12)/ 399/,OP34(12)/3457/,OP56(12)/ 129/,
X OVAL(12)/ 148/,OTYP(12)/ 7/
C BP
DATA OP12(13)/ 401/,OP34(13)/ 129/,OP56(13)/ 129/,
X OVAL(13)/ 129/,OTYP(13)/ 7/
C BR
DATA OP12(14)/ 403/,OP34(14)/ 129/,OP56(14)/ 129/,
X OVAL(14)/ 144/,OTYP(14)/ 7/
C BR7
DATA OP12(15)/ 403/,OP34(15)/4481/,OP56(15)/ 129/,
X OVAL(15)/ 143/,OTYP(15)/ 7/
C BT
DATA OP12(16)/ 405/,OP34(16)/ 129/,OP56(16)/ 129/,
X OVAL(16)/ 128/,OTYP(16)/ 8/
C BZ
DATA OP12(17)/ 411/,OP34(17)/ 129/,OP56(17)/ 129/,
X OVAL(17)/ 132/,OTYP(17)/ 7/
C CI
DATA OP12(18)/ 522/,OP34(18)/ 129/,OP56(18)/ 129/,
X OVAL(18)/ 37/,OTYP(18)/ 6/
C CLR
DATA OP12(19)/ 525/,OP34(19)/2433/,OP56(19)/ 129/,
X OVAL(19)/ 112/,OTYP(19)/ 2/
C CM
DATA OP12(20)/ 526/,OP34(20)/ 129/,OP56(20)/ 129/,
X OVAL(20)/ 141/,OTYP(20)/ 2/
C COM
DATA OP12(21)/ 528/,OP34(21)/1793/,OP56(21)/ 129/,
X OVAL(21)/ 24/,OTYP(21)/ 2/
C DC
DATA OP12(22)/ 644/,OP34(22)/ 129/,OP56(22)/ 129/,
X OVAL(22)/ 0/,OTYP(22)/ 5/
C DCI
DATA OP12(23)/ 644/,OP34(23)/1281/,OP56(23)/ 129/,
X OVAL(23)/ 42/,OTYP(23)/ 10/
C DI
DATA OP12(24)/ 650/,OP34(24)/ 129/,OP56(24)/ 129/,
X OVAL(24)/ 26/,OTYP(24)/ 2/
C DS
DATA OP12(25)/ 660/,OP34(25)/ 129/,OP56(25)/ 129/,
X OVAL(25)/ 48/,OTYP(25)/ 3/
C EI
DATA OP12(26)/ 778/,OP34(26)/ 129/,OP56(26)/ 129/,
X OVAL(26)/ 27/,OTYP(26)/ 2/
C EJECT
DATA OP12(27)/ 779/,OP34(27)/ 772/,OP56(27)/2689/,
X OVAL(27)/ 0/,OTYP(27)/ 13/
C END
DATA OP12(28)/ 783/,OP34(28)/ 641/,OP56(28)/ 129/,
X OVAL(28)/ 0/,OTYP(28)/ 14/
C EQU
DATA OP12(29)/ 786/,OP34(29)/2817/,OP56(29)/ 129/,
X OVAL(29)/ 0/,OTYP(29)/ 12/
C IN
DATA OP12(30)/1295/,OP34(30)/ 129/,OP56(30)/ 129/,
X OVAL(30)/ 38/,OTYP(30)/ 6/
C INC
DATA OP12(31)/1295/,OP34(31)/ 513/,OP56(31)/ 129/,
X OVAL(31)/ 31/,OTYP(31)/ 2/
C INS
DATA OP12(32)/1295/,OP34(32)/2561/,OP56(32)/ 129/,
X OVAL(32)/ 160/,OTYP(32)/ 4/
C JMP
DATA OP12(33)/1422/,OP34(33)/2177/,OP56(33)/ 129/,
X OVAL(33)/ 41/,OTYP(33)/ 10/
C LI
DATA OP12(34)/1674/,OP34(34)/ 129/,OP56(34)/ 129/,
X OVAL(34)/ 32/,OTYP(34)/ 6/
C LIS
DATA OP12(35)/1674/,OP34(35)/2561/,OP56(35)/ 129/,
X OVAL(35)/ 112/,OTYP(35)/ 4/
C LISL
DATA OP12(36)/1674/,OP34(36)/2573/,OP56(36)/ 129/,
X OVAL(36)/ 104/,OTYP(36)/ 15/
C LISU
DATA OP12(37)/1674/,OP34(37)/2582/,OP56(37)/ 129/,
X OVAL(37)/ 96/,OTYP(37)/ 15/
C LM
DATA OP12(38)/1678/,OP34(38)/ 129/,OP56(38)/ 129/,
X OVAL(38)/ 22/,OTYP(38)/ 2/
C LNK
DATA OP12(39)/1679/,OP34(39)/1537/,OP56(39)/ 129/,
X OVAL(39)/ 25/,OTYP(39)/ 2/
C LR
DATA OP12(40)/1683/,OP34(40)/ 129/,OP56(40)/ 129/,
X OVAL(40)/ 0/,OTYP(40)/ 1/
C NI
DATA OP12(41)/1930/,OP34(41)/ 129/,OP56(41)/ 129/,
X OVAL(41)/ 33/,OTYP(41)/ 6/
C NM
DATA OP12(42)/1934/,OP34(42)/ 129/,OP56(42)/ 129/,
X OVAL(42)/ 138/,OTYP(42)/ 2/
C NOP
DATA OP12(43)/1936/,OP34(43)/2177/,OP56(43)/ 129/,
X OVAL(43)/ 43/,OTYP(43)/ 2/
C NS
DATA OP12(44)/1940/,OP34(44)/ 129/,OP56(44)/ 129/,
X OVAL(44)/ 240/,OTYP(44)/ 3/
C OI
DATA OP12(45)/2058/,OP34(45)/ 129/,OP56(45)/ 129/,
X OVAL(45)/ 34/,OTYP(45)/ 6/
C OM
DATA OP12(46)/2062/,OP34(46)/ 129/,OP56(46)/ 129/,
X OVAL(46)/ 139/,OTYP(46)/ 2/
C ORG
DATA OP12(47)/2067/,OP34(47)/1025/,OP56(47)/ 129/,
X OVAL(47)/ 0/,OTYP(47)/ 11/
C OUT
DATA OP12(48)/2070/,OP34(48)/2689/,OP56(48)/ 129/,
X OVAL(48)/ 39/,OTYP(48)/ 6/
C OUTS
DATA OP12(49)/2070/,OP34(49)/2708/,OP56(49)/ 129/,
X OVAL(49)/ 176/,OTYP(49)/ 4/
C PI
DATA OP12(50)/2186/,OP34(50)/ 129/,OP56(50)/ 129/,
X OVAL(50)/ 40/,OTYP(50)/ 10/
C PK
DATA OP12(51)/2188/,OP34(51)/ 129/,OP56(51)/ 129/,
X OVAL(51)/ 12/,OTYP(51)/ 2/
C POP
DATA OP12(52)/2192/,OP34(52)/2177/,OP56(52)/ 129/,
X OVAL(52)/ 28/,OTYP(52)/ 2/
C PRINT
DATA OP12(53)/2195/,OP34(53)/1295/,OP56(53)/2689/,
X OVAL(53)/ 0/,OTYP(53)/ 13/
C PUNCH
DATA OP12(54)/2198/,OP34(54)/1924/,OP56(54)/1153/,
X OVAL(54)/ 0/,OTYP(54)/ 13/
C SL
DATA OP12(55)/2573/,OP34(55)/ 129/,OP56(55)/ 129/,
X OVAL(55)/ 17/,OTYP(55)/ 16/
DATA OP12(56)/2579/,OP34(56)/ 129/,OP56(56)/ 129/,
X OVAL(56)/ 16/,OTYP(56)/ 16/
C ST
DATA OP12(57)/2581/,OP34(57)/ 129/,OP56(57)/ 129/,
X OVAL(57)/ 23/,OTYP(57)/ 2/
C TITLE
DATA OP12(58)/2698/,OP34(58)/2701/,OP56(58)/ 769/,
X OVAL(58)/ 0/,OTYP(58)/ 13/
C XDC
DATA OP12(59)/3205/,OP34(59)/ 513/,OP56(59)/ 129/,
X OVAL(59)/ 44/,OTYP(59)/ 2/
C XI
DATA OP12(60)/3210/,OP34(60)/ 129/,OP56(60)/ 129/,
X OVAL(60)/ 35/,OTYP(60)/ 6/
C XM
DATA OP12(61)/3214/,OP34(61)/ 129/,OP56(61)/ 129/,
X OVAL(61)/ 140/,OTYP(61)/ 2/
C XS
DATA OP12(62)/3220/,OP34(62)/ 129/,OP56(62)/ 129/,
X OVAL(62)/ 224/,OTYP(62)/ 3/
DO 10 I=1,80
10 IHDR(I) = HDR(I)
IPAGE = PAGE
DO 20 I = 1,64
20 ILETAB(I) = LETAB(I)
IKBK = KBK
IKAP = KAP
IKPL = KPL
IKMI = KMI
IKKO = KKO
DO 30 I = 1,63
IOP12(I) = OP12(I)
IOP34(I) = OP34(I)
IOP56(I) = OP56(I)
IOVAL(I) = OVAL(I)
30 IOTYP(I) = OTYP(I)
RETURN
END
C----------------------------------------------------------------------
INTEGER FUNCTION IASCI(K)
IF (K.EQ.1) IASCI=32
IF (K.GT.1.AND.K.LT.28) IASCI=K+63
IF (K.GT.27.AND.K.LT.38) IASCI=K+20
IF (K.GT.37.AND.K.LT.53) IASCI=K-5
IF (K.GT.52.AND.K.LT.60) IASCI=K+5
IF (K.GT.59) IASCI=K+31
RETURN
END
C---------------------------------------------------------------------
SUBROUTINE EVAL (S,VL,VH,ERC,FLG)
INTEGER S,VL,VH,FLG,BA,R1,R3,VT
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IIC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
LOGICAL ERC,TFLG
LOGICAL BFLG
DIMENSION S(18)
DATA KST/47/,KKAP/44/,LBJ/1/,KD/5/,KH/9/,KO/16/,KKB/3/,KC/4/
X,KA/2/,KE/6/,KF/7/,K0/28/,K1/29/,K2/30/,K3/31/,K4/32/,K5/33/
X,K7/35/,K8/36/,K9/37/,KT/21/,K6/34/
DATA KLN/53/
DATA KPD/51/
BFLG=.FALSE.
TFLG=.FALSE.
DO 100 I=1,18
IF (S(I).EQ.KLN) GO TO 110
IF (S(I).EQ.LBJ) GO TO 120
IF (S(I).EQ.KPD) GO TO 105
100 CONTINUE
GO TO 120
105 BFLG=.TRUE.
110 TFLG=.TRUE.
IF (S(1).NE.KC.OR.S(2).NE.KKAP) S(I)=LBJ
120 ERC=.FALSE.
FLG=1
I=1
VL=0
VH=0
IF (S(1).EQ.LBJ) RETURN
IF (S(1).EQ.KST) GO TO 500
IF (S(1).GE.K0) GO TO 300
IF (S(2).NE.KKAP) GO TO 400
I=3
IF (S(1).NE.KD) GO TO 10
300 BA=10
GO TO 310
10 IF (S(1).NE.KH) GO TO 20
BA=16
GO TO 310
20 IF (S(1).NE.KO) GO TO 30
BA=8
GO TO 310
30 IF (S(1).NE.KKB) GO TO 40
BA=2
GO TO 310
40 IF (S(1).NE.KC) GO TO 50
VH=0
45 VL=IASCI(S(I))
I=I+1
IF (S(I).EQ.KKAP) RETURN
IF (I.GT.4) GO TO 50
VH=VL
GO TO 45
50 CONTINUE
60 ERC=.TRUE.
RETURN
310 R1=BA-9
IF (R1.LT.0) R1=0
R3=BA+27
IF (R3.GT.37)R3=37
ERC=.FALSE.
VL=0
VH=0
320 IF ((S(I).EQ.KKAP).OR.(S(I).EQ.LBJ)) GO TO 350
IF (S(I).GT.R1) GO TO 330
IC=S(I)+8
GO TO 340
330 IF ((S(I).LT.K0).OR.(S(I).GT.R3)) GO TO 60
IC=S(I)-K0
340 VL=VL*BA+IC
VH=VH*BA
CALL M256(VL,VH)
I=I+1
GO TO 320
350 IF (.NOT.TFLG) RETURN
IF (.NOT.BFLG) VL=VH
VH=0
RETURN
400 CALL HASH (S,VT)
IF (VT.EQ.0) GO TO 60
VL=SVALL(VT)
VH=SVALH(VT)
FLG=SFLG(VT)
GO TO 350
500 VL=LOCL
VH=LOCH
GO TO 350
END
C-----------------------------------------------------------------------
SUBROUTINE M256(IL,IH)
C MAINTAINS 2 8-BIT VALUES IN 16 BIT 2'S COMPLEMENT FORM
IM=MOD(IL,256)
IC=IL/256
IL=MOD((IM+256),256)
IF (IM.LT.0) IC=IC+255
IH=MOD((IH+IC+256),256)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE LIST (IBCT,I1,I2,I3,IMAGE)
DIMENSION IMAGE(80)
INTEGER IOL(10)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
EQUIVALENCE(LETAB(1),LBK)
IF (ERF) LINE=LINE+1
ERF=.FALSE.
LINE=LINE+1
IF (LINE.GT.54) CALL TOFM
DO 10 I=1,10
10 IOL(I)=LBK
IK=IBCT+1
GO TO (100,200,300,400),IK
400 CALL HXOUT (I3,IOL(9),IOL(10),IDUM)
300 CALL HXOUT (I2,IOL(7),IOL(8),IDUM)
200 CALL HXOUT (I1,IOL(5),IOL(6),IDUM)
CALL HXOUT (LOCL,IOL(3),IOL(4),IDUM)
CALL HXOUT (LOCH,IOL(1),IOL(2),IDUM)
100 WRITE (PR,1) LINECOUNT,IOL,(IMAGE(JK),JK=1,66)
1 FORMAT (1H ,I5,1X,4A1,3(1X,2A1),1X,66A1)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE LABER
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER R, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
IERC=IERC+1
ERF=.TRUE.
WRITE (PR,1)LINECOUNT
1 FORMAT (19H **SYMBOL AREA FULL,4X,7HLINE # ,I5)
RETURN
END
C---------------------------------------------------------------------
SUBROUTINE EXPRE (F,VL,VH,ERC,FLG)
LOGICAL KFG
LOGICAL ERC
INTEGER F(32),S(18),PROP,CVL,CVH,VL,VH,FLG,VT
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. OPS(3) ,IG(2),
. IOPB(16), KB, ICK
INTEGER HDR, PAGE, OPS,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
KFG=.TRUE.
VL=0
VH=0
PROP=2
I=1
5 DO 10 J=1,18
10 S(J)=OPS(1)
J=1
15 DO 20 K=1,3
IF (F(I).EQ.IG(1)) KFG=.NOT.KFG
IF (.NOT.KFG) GO TO 20
IF (F(I).EQ.OPS(K)) GO TO 100
20 CONTINUE
S(J)=F(I)
J=J+1
IF (J.GT.18) GO TO 150
I=I+1
IF (I.GT.32) GO TO 150
GO TO 15
100 CALL EVAL (S,CVL,CVH,ERC,FLG)
IF ((FLG.EQ.0).OR.(FLG.EQ.4).OR.ERC) GO TO 145
GO TO (145,110,120),PROP
120 CVL=-CVL
CVH=-CVH
CALL M256 (CVL,CVH)
110 VL=VL+CVL
VH=VH+CVH
CALL M256(VL,VH)
PROP=K
I=I+1
IF (K.GT.1) GO TO 5
145 RETURN
150 ERC=.TRUE.
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE PHDR
INTEGER SBLK(4)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
IF (KB.EQ.0) KB=1
IF (KB.GT.1) CALL OUTPP
CALL HXOUT (LOCH,SBLK(1),SBLK(2),IDUM)
CALL HXOUT (LOCL,SBLK(3),SBLK(4),IDUM)
WRITE (PU,1) SBLK
1 FORMAT (1HS,4A1)
RETURN
END
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
SUBROUTINE OUTPP
INTEGER HEX
C OUTPUTS A LINE OF PUNCH DATA
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
EQUIVALENCE (L0,LETAB(1))
LOGICAL ERF
C***********************************************************************
ICK=HEX(ICK)
WRITE (PU,1) IOPB,ICK
1 FORMAT (1HX,16A1,A1)
DO 100 I=1,16
100 IOPB(I)=L0
ICK=0
KB=1
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE OFINI
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
IF (KB.GT.1) CALL OUTPP
WRITE (PU,1)
1 FORMAT (1H*)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE LR(IN,I,IV)
DIMENSION IN(80)
INTEGER FLG
LOGICAL ER
INTEGER LR12(25),LR34(25),LRVL(25),EXPR(32)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG,OC, PR, PU
LOGICAL ERF
C**-******************************************************************
C A,D
DATA LR12( 1)/ 305/,LR34( 1)/ 641/,LRVL( 1)/ 78/
C A,I
DATA LR12( 2)/ 305/,LR34( 2)/1281/,LRVL( 2)/ 77/
C A,IS
DATA LR12( 3)/ 305/,LR34( 3)/1300/,LRVL( 3)/ 10/
C A,KL
DATA LR12( 4)/ 305/,LR34( 4)/1549/,LRVL( 4)/ 1/
C A,KU
DATA LR12( 5)/ 305/,LR34( 5)/1558/,LRVL( 5)/ 0/
C A,QL
DATA LR12( 6)/ 305/,LR34( 6)/2317/,LRVL( 6)/ 3/
C A,QU
DATA LR12( 7)/ 305/,LR34( 7)/2326/,LRVL( 7)/ 2/
C A,S
DATA LR12( 8)/ 305/,LR34( 8)/2561/,LRVL( 8)/ 76/
C DC,H
DATA LR12( 9)/ 644/,LR34( 9)/6281/,LRVL( 9)/ 16/
C DC,Q
DATA LR12(10)/ 644/,LR34(10)/6290/,LRVL(10)/ 15/
C D,A
DATA LR12(11)/ 689/,LR34(11)/ 257/,LRVL(11)/ 94/
C H,DC
DATA LR12(12)/1201/,LR34(12)/ 644/,LRVL(12)/ 17/
C IS,A
DATA LR12(13)/1300/,LR34(13)/6274/,LRVL(13)/ 11/
C I,A
DATA LR12(14)/1329/,LR34(14)/ 257/,LRVL(14)/ 93/
C J,W
DATA LR12(15)/1457/,LR34(15)/3073/,LRVL(15)/ 30/
C KL,A
DATA LR12(16)/1549/,LR34(16)/6274/,LRVL(16)/ 5/
C KU,A
DATA LR12(17)/1558/,LR34(17)/6274/,LRVL(17)/ 4/
C K,P
DATA LR12(18)/1585/,LR34(18)/2177/,LRVL(18)/ 8/
C P0,Q
DATA LR12(19)/2204/,LR34(19)/6290/,LRVL(19)/ 13/
C P,K
DATA LR12(20)/2225/,LR34(20)/1537/,LRVL(20)/ 9/
C QL,A
DATA LR12(21)/2317/,LR34(21)/6274/,LRVL(21)/ 7/
C QU,A
DATA LR12(22)/2326/,LR34(22)/6274/,LRVL(22)/ 6/
C Q,DC
DATA LR12(23)/2353/,LR34(23)/ 644/,LRVL(23)/ 14/
C S,A
DATA LR12(24)/2609/,LR34(24)/ 257/,LRVL(24)/ 92/
C W,J
DATA LR12(25)/3121/,LR34(25)/1409/,LRVL(25)/ 29/
C
KA = 2
C
IV=43
CALL GETFL (IN,I,EXPR,32,ER)
IF (.NOT.ER) GO TO 100
50 CALL SCERR(3)
RETURN
100 IF (EXPR(5).NE.KBK) GO TO 200
IC12=IPAK(EXPR)
IC34=IPAK(EXPR(3))
DO 110 J=1,25
IF (IC12.NE.LR12(J)) GO TO 110
IF (IC34.EQ.LR34(J)) GO TO 300
110 CONTINUE
200 IF ((EXPR(1).EQ.KA).AND.(EXPR(2).EQ.KKO)) GO TO 250
IV=80
DO 210 J=1,32
IF (EXPR(J).EQ.KKO) GO TO 220
210 CONTINUE
GO TO 50
220 EXPR(J)=KBK
IF (EXPR(J+1).NE.KA) GO TO 50
L=1
GO TO 260
250 IV=64
L=3
260 CALL EXPRE (EXPR(L),IL,IH,ER,FLG)
CALL FLGCK (ER,FLG)
IF((IH.NE.0).OR.(IL.GT.14)) GO TO 50
IV=IV+IL
RETURN
300 IV=LRVL(J)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE SYMLS
C PRINTS SYMBOL TABLE
INTEGER KO(72)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
WRITE (PR,1)
1 FORMAT (1H1)
40 DO 50 I=1,72
50 KO(I)=LETAB(1)
K=1
C
C
C SYMBOL TABLE SIZE *************************** SYMBOL TABLE SIZE
C
75 DO 100 J=1,800
IF (CH12(J).NE.0) GO TO 110
100 CONTINUE
GO TO 170
C
C SYMBOL TABLE SIZE *************************** SYMBOL TABLE SIZE
C
110 DO 120 I=1,800
IF (CH12(I).EQ.0) GO TO 120
117 IF (CH34(I)-CH34(J)) 119,118,120
118 IF (CH56(I)-CH56(J)) 119,119,120
119 J=I
120 CONTINUE
GO TO 150
150 CALL UNPAK(CH12(J),KO(K))
CALL UNPAK(CH34(J),KO(K+2))
CALL UNPAK(CH56(J),KO(K+4))
IF (SFLG(J).EQ.1) KO(K+6)=LETAB(56)
CALL HXOUT(SVALH(J),KO(K+7),KO(K+8),IDUM)
CALL HXOUT(SVALL(J),KO(K+9),KO(K+10),IDUM)
N=K+5
CH12(J)=0
DO 160 M=K,N
IK=KO(M)
160 KO(M)=LETAB(IK)
K=K+12
IF (K.LT.73) GO TO 75
WRITE (PR,2) KO
2 FORMAT (1H ,72A1)
GO TO 40
170 WRITE (PR,2) KO
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE OPSRC(S,I)
C RETURNS INDEX TO OP TABLE
INTEGER S(6)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C*********************************************************************
DIMENSION ICX(6)
DATA ICX/16,8,4,2,1,0/
I12=IPAK(S)
I34=IPAK(S(3))
I56=IPAK(S(5))
I=32
DO 200 K=1,6
IF (I12-OP12(I)) 100,50,110
50 IF (I34-OP34(I)) 100,60,110
60 IF (I56-OP56(I)) 100,400,110
100 I=I-ICX(K)
GO TO 200
110 I=I+ICX(K)
200 CONTINUE
I=0
400 RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE HASH(SY,IN)
INTEGER SY(6)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
I12=IPAK(SY)
I34=IPAK(SY(3))
I56=IPAK(SY(5))
C
C SYMBOL TABLE SIZE *************************** SYMBOL TABLE SIZE
C
IN=MOD(I12,800)
IN=IN+1
IST=IN
50 IF (CH12(IN).EQ.0) GO TO 200
IF((I12.EQ.CH12(IN)).AND.(I34.EQ.CH34(IN)).AND.(I56.EQ.CH56(IN)))
XRETURN
IN=IN+1
C
C SYMBOL TABLE SIZE *************************** SYMBOL TABLE SIZE
C
IF (IN.GT.800) IN=1
IF (IN.NE.IST)GO TO 50
IN=0
RETURN
200 CH12(IN)=I12
CH34(IN)=I34
CH56(IN)=I56
SVALH(IN)=0
SVALL(IN)=0
SFLG(IN)=0
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE GETFL(IN,I,OU,ISZ,ER)
DIMENSION IN(80)
C ASSEMBLER COMMON
INTEGER OU(32),SZ,CC
LOGICAL LFG,ER
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
EQUIVALENCE (LBK,LETAB(1)),(LAP,LETAB(44))
LFG=.TRUE.
ER=.FALSE.
DO 10 J=1,ISZ
10 OU(J)=1
100 IF (IN(I).NE.LBK) GO TO 200
I=I+1
IF (I.LE.80) GO TO 100
110 ER=.TRUE.
RETURN
200 DO 300 J=1,ISZ
OU(J)=LETER(IN(I))
IF (IN(I).EQ.LAP) LFG=.NOT.LFG
I=I+1
IF (I.GT.80) GO TO 110
IF (LFG.AND.(IN(I).EQ.LBK)) GO TO 310
300 CONTINUE
310 IF (IN(I).EQ.LBK) RETURN
I=I+1
IF (I.LE.80) GO TO 310
GO TO 110
END
C-----------------------------------------------------------------------
SUBROUTINE OUTP(IBCT,I1,I2,I3)
C FILLS BUFFER WITH PUNCH OUTPUT DATA
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
DIMENSION IB(3)
IF (IBCT.EQ.0) RETURN
IB(1)=I1
IB(2)=I2
IB(3)=I3
DO 100 I=1,IBCT
IF (KB.GT.16) CALL OUTPP
CALL HXOUT(IB(I),IOPB(KB),IOPB(KB+1),IK)
ICK=MOD((IK+ICK),16)
100 KB=KB+2
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE HXOUT (I,I1,I2,ICK)
INTEGER HEX
C RETURNS THE 2CHARACTER REPRESENTATION OF THE 8-BIT VALUE IN I
I1=I/16
I2=MOD(I,16)
ICK=MOD((I1+I2),16)
I1=HEX(I1)
I2=HEX(I2)
RETURN
END
C-----------------------------------------------------------------------
INTEGER FUNCTION HEX(I)
INTEGER HEXTAB(16)
DATA HEXTAB /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HA,1HB,1HC,
X1HD,1HE,1HF/
HEX=HEXTAB(I+1)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE TOFM
C EJECTS A PAGE
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
PAGE=PAGE+1
LINE=1
WRITE (PR,1) PAGE
1 FORMAT ( 8H1F8X V03,30X,5HPAGE ,I3)
WRITE (PR,2) HDR
2 FORMAT (1H ,80A1)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE FLGCK (ER,FLG)
C CHECKS RESULTS OF EXPRESION EVALUATION FOR VALIDITY
LOGICAL ER
INTEGER FLG
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
IF (.NOT.ER) GO TO 100
WRITE (PR,1) LINECOUNT
1 FORMAT (26H **BAD CONSTANT IN OPERAND,4X,7HLINE # ,I5)
50 ERF=.TRUE.
IERC=IERC+1
RETURN
100 IF (FLG.NE.0) GO TO 200
WRITE (PR,2) LINECOUNT
2 FORMAT (30H **UNDEFINED SYMBOL IN OPERAND,4X,7HLINE # ,I5)
GO TO 50
200 IF (FLG.NE.4) RETURN
WRITE (PR,3)LINECOUNT
3 FORMAT (37H **MULTIPLY DEFINED SYMBOL IN OPERAND,4X,7HLINE # ,I5)
GO TO 50
END
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
SUBROUTINE OVFER
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
ERF=.TRUE.
C IERC=IERC+1
C WRITE (PR,1) LINECOUNT
C 1 FORMAT (24H **OPERAND EXCEEDS RANGE,4X,7HLINE # ,I5)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE OPERR
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
ERF=.TRUE.
IERC=IERC+1
WRITE (PR,1)LINECOUNT
1 FORMAT (19H **UNKNOWN OPERATOR,4X,7HLINE # ,I5)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE PHERR
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
ERF=.TRUE.
IERC=IERC+1
WRITE (PR,1)LINECOUNT
1 FORMAT (25H **MULTIPLY DEFINED LABEL,4X,7HLINE # ,I5)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE SCERR(J)
C OUTPUTS SCAN ERROR FOR FIELD J
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH, LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
GO TO (100,200,300),J
100 WRITE (PR,1) LINECOUNT
1 FORMAT (15H **LABEL SYNTAX,4X,7HLINE # ,I5)
110 ERF=.TRUE.
IERC=IERC+1
RETURN
200 WRITE (PR,2)LINECOUNT
2 FORMAT (18H **OPERATOR SYNTAX,4X,7HLINE # ,I5)
GO TO 110
300 WRITE (PR,3) LINECOUNT
3 FORMAT (17H **OPERAND SYNTAX,4X,7HLINE # ,I5)
GO TO 110
END
C-----------------------------------------------------------------------
INTEGER FUNCTION IPAK(K)
DIMENSION K(2)
IPAK=K(1)*128+K(2)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE UNPAK(J,K)
DIMENSION K(2)
K(1)=J/128
K(2)=J-K(1)*128
RETURN
END
C-----------------------------------------------------------------------
INTEGER FUNCTION LETER(K)
C ASSEMBLER COMMON
C
COMMON IERC, ERF,
. IC, OC, PR, PU,
. LETAB(64),
. HDR(80), PAGE, LINE,
. OP12(63), OP34(63), OP56(63), OVAL(63), OTYP(63),
. CH12(800),CH34(800),CH56(800),SVALL(800),SVALH(800),SFLG(800),
. LOCL, LOCH,LINECOUNT,
. KBK, KPL, KMI, KAP, KKO,
. IOPB(16), KB, ICK
INTEGER HDR, PAGE,
. OP12, OP34, OP56, OVAL, OTYP, CH12, CH34, CH56, SVALL, SVALH,
. SFLG, OC, PR, PU
LOGICAL ERF
C***********************************************************************
DO 10 I=1,64
IF (K.EQ.LETAB(I)) GO TO 20
10 CONTINUE
I=0
20 LETER=I
RETURN
END
CCCCCC
SUBROUTINE GETLL(IN,I,OU,ISZ,ER)
DIMENSION IN(80)
C
INTEGER OU(32),SZ,CC
LOGICAL LFG,ER
COMMON IERC,ERF,
1 IC, OC, PR, PU,
2 LETAB(64), HDR(80),PAGE, LINE,
3 OP12(63), OP34(63),OP56(63),OVAL(63),OTYP(63),
4 CH12(800),CH34(800),CH56(800),SVALL(800),
5 SVALH(800),SFLG(800),
6 LOCL, LOCH, LINECOUNT,KBK, KPL, KMI, KAP, KKO,
7 IOPB(16), KB,ICK
C
INTEGER HDR, PAGE,
1 OP12, OP34,OP56,OVAL,OTYP,CH12,CH34,CH56,SVALL,SVALH,
2 SFLG, OC, PR, PU
LOGICAL ERF
C
EQUIVALENCE (LBK,LETAB(1)),(LAP,LETAB(44))
C
LFG = .TRUE.
ER = .FALSE.
DO 10 J=1,ISZ
10 OU(J) = 1
C
100 IF( IN(I).NE.LBK) GO TO 200
I = I + 1
IF (I.LE.80) GO TO 100
110 ER = .TRUE.
C
RETURN
C
200 DO 300 J=1,ISZ
OU(J) = LETER(IN(I))
IF(IN(I).EQ.LAP) LFG=.NOT.LFG
I = I + 1
IF(I.GT.80) GO TO 110
IF(LFG.AND.(IN(I).EQ.LBK)) GO TO 310
300 CONTINUE
C
310 IF (IN(I).EQ.LBK) RETURN
C
I=I+1
IF(I.LE.80) GO TO 310
GO TO 110
END